【 ＶＢＡサンプルプログラム 】

☆エクセルのリストボックス間のコピーにおいて、マウス（ドラッグ＆ドロップ）により、コピー先リストの任意のポイントへの挿入と、
コピー先のリスト内でのデータ移動が容易にできるＶＢＡプログラム。（最新版）


Dim Mx As Integer, Lx As Integer, Dp As Integer, Ip As Integer
Dim ClpId As Integer, RpFg As Integer, Sbsz As Integer, MdFg As Integer
Dim Temp As String

Private Sub UserForm_Initialize()
ListBox1.List = _
Array("Excel", "Access", "word", "Outlook", "PowerPoint", "FrontPage", "VisualWebDeveloper", "VisualBasic", "SQL Server")

Mx = 0: Lx = 0: ClpId = 0: RpFg = 1: Sbsz = 18: MdFg = 0

End Sub

Private Sub ListBox1_AfterUpdate()

ClpId = ListBox1.ListIndex

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Dim Fg As Integer

ClpId = ListBox1.ListIndex

If RpFg = 1 Then

Call Rp_Check(ClpId, Fg)

End If

If Fg = 0 Then

ListBox2.SetFocus

ListBox2.AddItem ListBox1.List(ClpId)

Mx = ListBox2.ListCount

Y0 = Mx - 1: Lx = Y0

ListBox2.ListIndex = Y0

End If

End Sub

Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

MdFg = 1

End Sub

Private Sub ListBox1_MouseMove(ByVal Button As _
Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)

Dim MyDataObject1 As DataObject
Dim Effect As Integer

If Button = 1 And ListBox1.Value > 0 Then
Lx = -1
Set MyDataObject1 = New DataObject
MyDataObject1.SetText ListBox1.Value
Effect = MyDataObject1.StartDrag
End If

End Sub

Private Sub ListBox2_BeforeDragOver(ByVal Cancel As _
MSForms.ReturnBoolean, ByVal Data As _
MSForms.DataObject, ByVal X As Single, _
ByVal Y As Single, ByVal DragState As Long, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = 1

Y0 = (Y * 1000 / 975) \ 10
If Y0 <> Lx Then
If Y0 >= 0 And Y0 < Mx Then
ListBox2.ListIndex = Y0: Lx = Y0
Else
If Y0 >= Mx Then Y0 = Mx - 1
ListBox2.ListIndex = Y0: Lx = Y0
End If
End If

End Sub

Private Sub ListBox2_BeforeDropOrPaste(ByVal _
Cancel As MSForms.ReturnBoolean, _
ByVal Action As Long, ByVal Data As _
MSForms.DataObject, ByVal X As Single, _
ByVal Y As Single, ByVal Effect As _
MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1

Dim Fg As Integer

If RpFg = 1 Then

Call Rp_Check(ClpId, Fg)

End If

If Fg = 0 Then

ListBox2.AddItem Data.GetText

If ListBox2.ListCount > 1 Then
Call Lst2_Ins(ClpId)
Else
ListBox2.ListIndex = ListBox2.ListCount - 1
End If

End If

Mx = ListBox2.ListCount

End Sub

Private Sub ListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

MdFg = 1

End Sub

Private Sub ListBox2_MouseMove(ByVal Button As _
Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)

If Button = 1 Then
If X >= 0 And X < (ListBox2.Width - Sbsz) And Y >= 0 And Y < ListBox2.Height Then

If MdFg = 1 Then
Dp = ListBox2.ListIndex
MdFg = 2
End If

End If
End If

End Sub

Private Sub ListBox2_MouseUp(ByVal Button As _
Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)

If Dp >= 0 Then

Temp = ListBox2.List(Dp)

End If

If MdFg = 2 Then

If X >= 0 And X < (ListBox2.Width - Sbsz) And Y >= 0 And Y < ListBox2.Height Then
If Button = 1 And Dp >= 0 Then
Ip = ListBox2.ListIndex
If Ip <> Dp Then
Call Lst2_Del(Dp)
Call Lst2_Ins0(Ip, Temp)
End If
End If
End If

End If

MdFg = 0

End Sub

Sub Rp_Check(ChkId As Integer, Ch As Integer)

Dim P As Integer

For P = 0 To ListBox2.ListCount - 1

If ListBox2.List(P) = ListBox1.List(ChkId) Then Ch = 1

Next

End Sub

Sub Lst2_Ins(InsId As Integer)

Dim P As Integer

If ListBox2.ListIndex < 0 Then ListBox2.ListIndex = ListBox2.ListCount - 1

For P = ListBox2.ListCount - 2 To ListBox2.ListIndex Step -1

ListBox2.List(P + 1) = ListBox2.List(P)

Next

ListBox2.List(ListBox2.ListIndex) = ListBox1.List(InsId)

End Sub

Sub Lst2_Del(DelId As Integer)

Dim P As Integer

For P = DelId To ListBox2.ListCount - 2

ListBox2.List(P) = ListBox2.List(P + 1)

Next

End Sub

Sub Lst2_Ins0(InsId As Integer, Tmp As String)

Dim P As Integer

For P = ListBox2.ListCount - 2 To InsId Step -1

ListBox2.List(P + 1) = ListBox2.List(P)

Next

ListBox2.List(InsId) = Tmp

End Sub